Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/s_to_z/tpack/shells.pas

Pascal/Delphi Source File | 1996-09-15 | 8.9 KB | 319 lines

Unit Shells;

{ DOS/Windows/DLL Shells by Michael Ax; Inspired by Ken Henderson}

interface
Uses
  Forms, WinTypes, Controls, Classes, WinProcs, SysUtils, Messages
, PasUtils
, Working
, UserInfo;

Const
  ErrorThreshold = 32;
  ShowCommands: array[TWindowState] of Word =(SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED);
  DefaultProcessor = 'COMMAND.COM';

Type

  TShellOptions = (shlWaitTillDone,shlUseShell,shlMsgTillReady,shlMsgTillDone);
  TShellFlags = set of TShellOptions;

  TGenericShell = class(TDialogShell)
  private
    fCommand              : PString;
    fCommandLine          : PString;
    fFlags                : TShellFlags;
    fShellResult          : Word;
    fOnPreShell           : TNotifyEvent;
    fOnPostShell          : TNotifyEvent;
    fOnWait               : TNotifyEvent;
    fWorking              : TWorkingMsg;
  protected
    function DoShell: Word; Virtual;
    function GetCommand:String;
    procedure SetCommand(const Value:String);
    function GetCommandLine:String;
    procedure SetCommandLine(const Value:String);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); Override;
    procedure Execute; override;
    procedure Run(const aCmd,aParam:String);
    property Command : String read GetCommand write SetCommand;
    property Parameters : String read GetCommandLine write SetCommandLine;
  published
    property Working     : TWorkingMsg read fWorking write fWorking;
    property Flags       : TShellFlags read fFlags write fFlags;
    property ShellResult : Word read fShellResult write fShellResult stored false;
    property OnPreShell  : TNotifyEvent read fOnPreShell write fOnPreShell;
    property OnPostShell : TNotifyEvent read fOnPostShell write fOnPostShell;
    property OnWait      : TnotifyEvent read fOnWait write fOnWait;
    end;

  TDLLShell = class(TGenericShell)
  public
    constructor Create(AOwner: TComponent); override;
    function DoShell: Word; Override;
  published
    property Module : String read GetCommand write SetCommand;
    property Proc : String read GetCommandLine write SetCommandLine;
    end;

  TWindowsShell = class(TGenericShell)
  private
    fShellResult          : Word;
    fWindowStyle          : TWindowState;
    fOnPreShell           : TNotifyEvent;
    fOnPostShell          : TNotifyEvent;
    fOnWait               : TNotifyEvent;
  protected
    function GetExecStr: String; Virtual;
    function DoShell: Word; Override;
    function GetTest:Boolean; Override;
    procedure SetNoString(const Value:String);
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Command;
    property Parameters;
    property WindowStyle : TWindowState read fWindowStyle write fWindowStyle;
    property ExecString  : String read GetExecStr write SetNoString stored false;
    end;


  TDosShell = class(TWindowsShell)
  {rather 'ComSpec' shell. if you want to shell using an alternative shell, use WindowsShell}
  private
  protected
    function GetComSpec: String; {returns default if blank}
  public
    constructor Create(AOwner: TComponent); override;
    function GetExecStr: String; override;
  published
    property ComSpec: String read GetComSpec write SetNoString stored false;
    end;


implementation

{-----------------------------------------------------------------------------------------}
{ TGenericShell                                                                           }
{-----------------------------------------------------------------------------------------}

constructor TGenericShell.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fCommand:=NullStr;
  fCommandLine:=NullStr;
end;

destructor TGenericShell.Destroy;
begin
  DisposeStr(fCommandLine);
  DisposeStr(fCommand);
  inherited Destroy;
end;

procedure TGenericShell.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then begin
    cx.NilIfSet(fWorking,AComponent);
    end;
end;

procedure TGenericShell.Run(const aCmd,aParam:String);
begin
  Command:=aCmd;
  Parameters:=aParam;
  Execute;
end;

Procedure TGenericShell.Execute;
begin
  if (fFlags*[shlMsgTillReady,shlMsgTillDone])<>[] then begin
    cx.MakeIfNil(fWorking,TWorkingMsg);
    fWorking.BusyOn;
    end;

  if Assigned(fOnPreShell) then
    fOnPreShell(Self);

  fShellResult:=DoShell;

  if Assigned(fOnPostShell) then
    fOnPostShell(Self); {must decipher error if any}

  if fWorking<>nil then begin
    fWorking.BusyOff;
    fWorking:=nil;
    end;

end;

function TGenericShell.DoShell:Word;
begin
  Result:=0;
  if (shlMsgTillReady in fFlags) and (fWorking<>nil) then begin
    fWorking.BusyOff;
    fWorking:=nil;
    end;
end;

{}

function TGenericShell.GetCommand:String;
begin
  Result := fCommand^;
end;

procedure TGenericShell.SetCommand(const Value:String);
begin
  AssignStr(fCommand, Value);
end;

{}

function TGenericShell.GetCommandLine:String;
begin
  Result := fCommandLine^;
end;

procedure TGenericShell.SetCommandLine(const Value:String);
begin
  AssignStr(fCommandLine, Value);
end;

{-----------------------------------------------------------------------------------------}
{ TDLLShell                                                                               }
{-----------------------------------------------------------------------------------------}

constructor TDLLShell.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

function TDLLShell.DoShell:Word;
var
  DllName,
  ProcName: PChar;
  LinkedProc: Procedure;
  Handle: THandle;
begin
{  Result:=0;
  if not FileExists(Module) then
    raise Exception.Create(classname+': Module '+Module+' does not exist!');}
  if ExtractFileExt(Module)='' then
    DllName:=MakePChar(ChangeFileExt(Module,'.DLL'))
  else
    DllName:=MakePChar(Module);
  try
    Handle:=LoadLibrary(DllName);
    if Handle<ErrorThreshold then
      raise Exception.Create(classname+': Handle for Module '+Module+' is '+inttostr(longint(Handle)));
    ProcName:=MakePChar(Proc);
    try
      TFarProc(@LinkedProc):= GetProcAddress(Handle, ProcName);
      if TFarProc(@LinkedProc)=nil then
        raise Exception.Create(classname+': Module '+Module+' has no procedure '+Proc);
      inherited DoShell; {can turn off message}
      LinkedProc;
    finally
      FreeLibrary(Handle);
      FreePChar(ProcName);
      end;
  finally
    FreePChar(DllName);
    end;
end;

{-----------------------------------------------------------------------------------------}
{ TWindowsShell                                                                           }
{-----------------------------------------------------------------------------------------}


constructor TWindowsShell.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

{}

function TWindowsShell.DoShell:Word;
var
  P:PChar;
begin
  p:=MakePChar(ExecString);
  Result:=WinExec(p, ShowCommands[fWindowStyle]);
  FreePChar(p);

  inherited DoShell; {can turn off message}

  If (Result<ErrorThreshold) then
    raise Exception.Create(classname+': DoShell Result '+inttostr(Result));

  while (shlWaitTillDone in Flags) and (GetModuleUsage(Result)>0) do begin
    Application.ProcessMessages;
    if Assigned(fOnWait) then
      fOnWait(Self);            {can stop waiting by removing flag}
    end;
end;

function TWindowsShell.GetTest:Boolean;
begin
  Result:= fShellResult=0;
end;

procedure TWindowsShell.SetNoString(const Value:String);
begin
end;

function TWindowsShell.GetExecStr:String;
begin
  Result:=Command+' '+Parameters;
end;

{-----------------------------------------------------------------------------------------}
{ TDosShell                                                                               }
{-----------------------------------------------------------------------------------------}


constructor TDosShell.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Include(fFlags,shlUseShell);
end;

function TDosShell.GetExecStr:String;
begin
  if shlUseShell in fFlags then
    Result:=ComSpec+' /C'
  else
    Result:='';
  Result:=Result+inherited GetExecStr;
end;

function TDosShell.GetComSpec: String;
begin

{  IF YOU HAVE WINDOS.DCU or PAS installed in \DELPHI\LIB then please activate the
  lines below.. }

{
  Result:=StrPas(GetEnvVar('COMSPEC'));
  if Result='' then
}

    Result:=DefaultProcessor;
end;


{-----------------------------------------------------------------------------------------}
{                                                                                         }
{-----------------------------------------------------------------------------------------}

end.